;;; make-font-sampler.lisp
;;; Wednesday May 29, 2002 SVS
;;; No warranties; use at your own risk.

;;; Makes an editor window that has a sample of all the fonts in the system for MCL.
;;; Adds an item called "Font Sampler" to your Edit menu.
;;; Very handy in OSX because of all the fonts therein.
;;; akh - use unicode chars, convert font name to unicode
;;; use *font-name-number-alist*

(in-package :ccl)

(export '(make-font-sampler)) ; so people can call it from the listener too

(defparameter *fwd-double-quote-char* (convert-char-to-unicode #\322 #$kcfstringencodingmacroman))
(defparameter *bwd-double-quote-char* (convert-char-to-unicode #\323 #$kcfstringencodingmacroman))
(defparameter *fwd-single-quote-char* (convert-char-to-unicode #\324 #$kcfstringencodingmacroman))
(defparameter *bwd-single-quote-char* (convert-char-to-unicode #\325 #$kcfstringencodingmacroman))

(defun make-font-sampler (&optional (fontsize 12))
  "Make a new fred window and fill it with examples of each font in the system."
  (let ((w (make-instance *default-editor-class* :window-title "Font Sampler")))
    (flet ((print-sample-line (fontname)
             (format w "The rain in Spain prefers ~C~A~C over ~F, don~Ct you think?!~%~%"
                     *fwd-double-quote-char*
                     fontname
                     *bwd-double-quote-char*
                     pi
                     *bwd-single-quote-char*)))
      (ed-set-view-font w (list "Monaco" 9 :srcor :plain '(:color-index 0)))
      (format w "This page was generated by the MCL expression (make-font-sampler ~D), ~%~
                 where ~D is the point-size of the samples desired.~%~
                 __________________________________________________~%~%" fontsize fontsize)
      
      (format w "Your System font is ~S:~%" (sys-font-spec)) 
      (ed-set-view-font w *sys-font-spec*) ; just use the cached value
      (print-sample-line (car *sys-font-spec*))
      (terpri w)
      (multiple-value-bind (cff cms)(font-codes (list fontsize :plain :srcor '(:color-index 0)))
        (dolist (font-pair *font-name-number-alist*)
          ;; names in font list are mac encoded
          (let* ((font-id (cdr font-pair))
                 ;(encoding (font-to-encoding-no-error font-id))
                 (font-uname (car font-pair)))
            (ed-set-view-font w '("Monaco" 9 :srcor :plain (:color-index 0)))
            (format w "This is ~S ~D:~%" font-uname fontsize)
            (ed-set-view-font w (font-spec (logior (ash font-id 16)(logand cff #xffff)) cms))
            (print-sample-line font-uname)))
        (fred-update w)
        (window-set-not-modified (window-key-handler w))))))

;;; Would be nice to have a submenu so you could give it a size argument. Let somebody else do it.
(when (not (find-menu-item (edit-menu) "Font Sampler"))
  (add-menu-items (edit-menu)
                  (make-instance 'window-menu-item
                    :menu-item-title "Font Sampler"
                    :menu-item-action
                    #'(lambda (w)
                        (declare (ignore w)) ; always make a new window
                        (make-font-sampler)))))


(format t "~%You should now have an item called \"Font Sampler\" to your Edit menu.")
(values)
